{INCLUDE FILE UOBJECT3 -- OBJECTS, CLASSES, RESOURCES, AND STREAMS}
{Copyright 1983, 1984, Apple Computer, Inc.}

{changed 05/01 1503 Changes to allow people to use Clascal on the Workshop}

{Segments: SgCLAini(tialize and Terminate), SgCLAres(ident), SgCLAc(o)ld, SgCLAdbg}

{$%+}

{$IFC fRngObject}
{$R+}
{$ELSEC}
{$R-}
{$ENDC}

{$IFC fSymObject}
{$D+}
{$ELSEC}
{$D-}
{$ENDC}

CONST

    trLevMemory = 60;
        { The std value of keyPresLimit, overridable by chaging the variable keyPresLimit }
    stdKeyPresLimit = 10;
    maxTallies = 3000; { < 32K DIV SIZEOF(TTally) }

TYPE

    S16 = STRING[16];

    TPS8 = ^S8;
    TPByte = ^Byte;
    TPAOC = PACKED ARRAY[1..32767] OF CHAR;
    TpPAOC = ^TPAOC;

    TppINTEGER = ^TpINTEGER;

    TPObject = ^TObject;

    TPPathName = ^PathName;
    TPEName = ^E_Name;

    TRecycleChain = RECORD
                    classPtr:   TClass;
                    chainLink:  TObject;
                    END;
    TPRecycleChain = ^TRecycleChain;
    THRecycleChain = ^TPRecycleChain;

    UnsignedByte = 0..255;

    TTypeCode = (yBoolean, yHexByte, yByte, yChar, yHexInteger, yInteger, yLongInt, yLongReal,
                 yLPoint, yLRect, yObject, yPoint, yPtr, yReal, yRect, yString, yArray);

  {We can't USE Unit UDRAW because it USES us; these are needed in EXTERNAL decls below for KitBug}
    FakePoint = RECORD v, h: INTEGER END;
    FakeRect = RECORD top, left, bottom, right: INTEGER END;
    FakeLPoint = RECORD v, h: LONGINT END;
    FakeLRect = RECORD top, left, bottom, right: LONGINT END;

{$IFC LibraryVersion < 20}
  { The following definitions come from PasLibCall and PPasLibC; if those files change, these
              will have to be changed too !!!! }
    dsProcCode = (dsResProg, dsSoftPwbtn, dsPrintDev, dsSetGPrefix, dsEnbDisk);

    dsProcParam = record
        case ProcCode : dsProcCode of
                dsResProg : (RProcessId : longint);
                dsSoftPwbtn  : (SPButton : boolean);
                dsPrintDev   : (PrDevice : e_name);
                dsSetGPrefix : (errnum : INTEGER;
                                 prefix : pathname);
                dsEnbDisk    : (DiskEvent : boolean);
                end;
{$ENDC}

  {Tallying}

    TTally = RECORD
        count:	        INTEGER;
        microseconds:   LONGINT;
        epPC:	        LONGINT;
        END;

    TTallyArray = ARRAY [1..maxTallies] OF TTally;

    TDTallyArray  = RECORD
        header: TArrayHeader;
        recs:   TTallyArray;    {name "recs" must be different from "records" in THIdxArray}
        END;
    TPDTallyArray = ^TDTallyArray;
    THTallies  = ^TPDTallyArray;        {An alias for a TArray of TTally}

  {Version Conversion Types}

    TDClasses = RECORD
        header:	        TArrayHeader;
        records:        TClassArray;
        END;
    TPDClasses = ^TDClasses;
    THClasses = ^TPDClasses;	        {An alias for a TArray of TClassInfo}

    TDSTables = RECORD
        header:	        TArrayHeader;
        records:        TSTableArray;
        END;
    TPDSTables = ^TDSTables;
    THSTables = ^TPDSTables;	        {An alias for a TArray of TPSliceTable}

    TDAuthorArray  = RECORD
        header:	        TArrayHeader;
        records:        TAuthorArray;
        END;
    TPDAuthorArray = ^TDAuthorArray;
    THAuthors = ^TPDAuthorArray;    {An alias for a TArray of TA32 (company and author)}

    TDAliasArray  = RECORD
        header:	        TArrayHeader;
        records:        TAliasArray;
        END;
    TPDAliasArray = ^TDAliasArray;
    THAliases  = ^TPDAliasArray;     {An alias for a TArray of TA8 (class alias)}

    TIdxArray = ARRAY [1..16000] OF INTEGER;

    TDIdxArray  = RECORD
        header:	        TArrayHeader;
        records:        TIdxArray;
        END;
    TPDIdxArray = ^TDIdxArray;
    THIdxArray = ^TPDIdxArray;	        {An alias for a TArray of INTEGER}

    TWorld = RECORD
        hExClasses:     THClasses;      {hExClasses^^ .records[i] is the TClassInfo of class no. i}
        hExSTables:     THSTables;      {hExSTables^^ .records[i] is the TPSliceTable of class no. i}
        hExAuthors:     THAuthors;      {hExAuthors^^ .records[i] is the i'th companyAndAuthor encountered}
        hExAliases:     THAliases;      {hExAliases^^ .records[i] is the i'th classAlias encountered}
        END;

VAR

    hMyClasses:	        THClasses;      {hMyClasses^^ .records[i] is the TClassInfo of class no. i}
    hMySTables:	        THSTables;      {hMySTables^^ .records[i] is the TPSliceTable of class no. i}
    hMyAuthors:	        THAuthors;      {hMyAuthors^^ .records[i] is the i'th companyAndAuthor encountered}
    hMyAliases:	        THAliases;      {hMyAliases^^ .records[i] is the i'th classAlias encountered}
    hMyHashName:        THIdxArray;     {hMyHashName^^.records[hashIndex] is 0 or the index i of a class}

    cObject:	        TClass;	        {The TClass of TObject}

{$IFC compatibleLists} {For TDynamicArray.Class and TIndexList.Class}
    cArray:	        TClass;	        {The TClass of TArray}
    cList:	        TClass;	        {The TClass of TList}
{$ENDC}

    availListScanner:   TListScanner;   {Heads of preallocated Scanner chains}
    availArrayScanner:  TArrayScanner;
    availStringScanner: TStringScanner;

    {$IFC fTrace}
    fTraceEnabled, fTraceSelf, fTraceClass: BOOLEAN;
      { Current method nesting level }
    tabLevel:		    INTEGER;
      { So EP calls don't have to pass a trace level parameter, it is saved here on the corresponding
        BP call. }
    traceLevels:	    ARRAY [0..trLevMemory] OF INTEGER;	        {indexed by tabLevel}
      { So EP can check for matching BP. }
    traceFrames:	    ARRAY [0..trLevMemory] OF LONGINT;	        {indexed by tabLevel}
      { To time procedure durations. }

    traceTimes:		    ARRAY [0..trLevMemory] OF LONGINT;	        {indexed by tabLevel}
      { kpcntr counts number of times AKeyPress has been called and only calls KeyPress every
        keyPresLimit times for performance reasons. }

    kpcntr:		    INTEGER;
      { TRUE IF returning to main screen after leaving debugger }
    returnToMain:	    BOOLEAN;
      { traceCount of 0 -> no tracing, traceCount of 1 means you have traced through defTraceCount methods
        so time to enter the debugger. }
    traceCount, defTraceCount: INTEGER;
      { Set with the Level command }
    curTraceLevel:	    INTEGER;
      { Break when you come to one of these methods }
    breakMethods:	    ARRAY [1..maxBreaks] OF RECORD
                                                        brClass, brMethod: S8;
                                                    END;
      { The number of valid break methods currently active }
    breakMCount:	    INTEGER;
      { TRUE IF showing the debugger prompt }
    showPrompt:		    BOOLEAN;
      { TRUE if BP is tallying procedure calls }
    tallyingCalls:	    BOOLEAN;
      { A hash table if tallyingCalls }
    tallies:		    THTallies;

(*  tallyOverhead:	    LONGINT;    {usual time spent calling and returning from BP, EP, or Tally} *)
(*  debugTime:		    LONGINT;    {cumulative time spend in BP and EP since tallying started} *)
    startTime:		    LONGINT;    {when tallying started}
    stopTime:		    LONGINT;    {when tallying last paused}
    segNames:		    TArray{[1..127] OF S8};

      { Used to avoid break point checking on methods we have already checked }
    lastBpPc:		    LONGINT;
    lastEpPc:		    LONGINT;
    {$ENDC}


{ ==================================== EXTERNAL AND FORWARD PROCEDURES ==================================== }


{$IFC LibraryVersion < 20}
  {So we don't need to use PasLibCall or PPasLibC; this may have to change if those .OBJ files change !!!!}
    PROCEDURE OutputRedirect (VAR errnum : INTEGER; VAR outfile : pathname; stopoutput : BOOLEAN); EXTERNAL;
    PROCEDURE DSPaslibCall (VAR ProcParam : dsProcParam); EXTERNAL;
{$ENDC}

  {We can't USE Unit UDRAW because it USES us}
    PROCEDURE InitErrorAbort(error: INTEGER); EXTERNAL;
    PROCEDURE TrmntExceptionHandler; EXTERNAL;

    {$IFC fDbgObject}
    FUNCTION  BindHeap(activeVsClip, doBind: BOOLEAN): THeap; EXTERNAL;
    {$ENDC}

  {We can't USE Unit UDRAW because it USES us}
    PROCEDURE PointToStr(pt: FakePoint; str: TPstring); EXTERNAL;
    PROCEDURE RectToStr(r: FakeRect; str: TPstring); EXTERNAL;
    PROCEDURE LPointToStr(pt: FakeLPoint; str: TPstring); EXTERNAL;
    PROCEDURE LRectToStr(r: FakeLRect; str: TPstring); EXTERNAL;

  {We can't USE Unit Storage because of type name conflicts (Ptr, Handle, ProcPtr)}
    PROCEDURE SetHeap(heap: THeap); EXTERNAL;
    PROCEDURE GetHeap(VAR heap: THeap); EXTERNAL;

  {We can't USE Unit QuickDraw because we can't use Storage; nor WM without using QuickDraw; nor UDraw, so...}
    PROCEDURE InitQDWM; EXTERNAL; {in UDraw}
    PROCEDURE DrawText(textBuf: TpINTEGER; firstByte, byteCount: INTEGER); EXTERNAL;
    FUNCTION  TextWidth(textBuf: TpINTEGER; firstByte, byteCount: INTEGER): INTEGER; EXTERNAL;
    PROCEDURE DrawLText(textBuf: TpINTEGER; firstByte, byteCount: INTEGER); EXTERNAL;

  {The rest are assembler routines in XFER and ARE declared in the INTERFACE of this unit}
    FUNCTION  LIntAndLInt(i, j: LONGINT): LONGINT; EXTERNAL;
    FUNCTION  LIntOrLInt(i, j: LONGINT): LONGINT; EXTERNAL;
    FUNCTION  LIntXorLInt(i, j: LONGINT): LONGINT; EXTERNAL;
    PROCEDURE XferLeft(source, dest: Ptr; nBytes: INTEGER); EXTERNAL;
    PROCEDURE XferRight(source, dest: Ptr; nBytes: INTEGER); EXTERNAL;
    FUNCTION  EqualBytes(source, dest: Ptr; nBytes: INTEGER): BOOLEAN; EXTERNAL;

  {The rest are assembler routines in CLASLIB and are NOT declared in the INTERFACE of this unit}
    FUNCTION  %_GetA5: LONGINT; EXTERNAL;
    PROCEDURE %_GoLisabug; EXTERNAL;

  {Forward}
    {$IFC fDebugMethods}
    PROCEDURE WriteDRecord(numLevels: INTEGER; hDRecord: Handle; posInDRecord: INTEGER;
                           PROCEDURE SupplyFields(PROCEDURE Field(nameAndType: S255))); FORWARD;
    {$ENDC}


{ ====================================== COLD UTILITIES ====================================== }




{$S SgCLAcld}
FUNCTION MakeIdxArray(numElements: INTEGER; sparse: BOOLEAN): THIdxArray;
    VAR anArray:    TArray;
        i:	    INTEGER;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    {$IFC fMaxTrace}EP;{$ENDC}
    IF sparse THEN
        numElements := (((numElements + 6) * 4) DIV 3);
    anArray := TArray.CREATE(NIL, mainHeap, numElements, SIZEOF(INTEGER));
    anArray.InsNullsAt(1, numElements);
    MakeIdxArray := THIdxArray(anArray);
(*****
    hArray := THIdxArray(TDynamicArray.CREATE(NIL, mainHeap, SIZEOF(INTEGER), numElements));
    FOR i := 1 TO numElements DO
        hArray^^.records[i] := 0;
    MakeIdxArray := hArray;
*****)
END;


{$S SgCLAcld}
PROCEDURE EachObject(heap: THeap; PROCEDURE DoToObject(object: TObject));
    VAR	 hz:	     THz;       { The heap as a UnitHz type }
         mpFirst:    LONGINT;   { The address of the first master pointer }
         mpLast:     LONGINT;   { The address of the last master pointer }
         mpIndex:    LONGINT;   { An index variable used for stepping through the master pointers }
         mp:	     LONGINT;   { the value of the master pointer at mpIndex }
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    {$IFC fMaxTrace}EP;{$ENDC}
    hz := THz(heap);
    mpFirst := ORD(@hz^.argpPool);
    mpLast := mpFirst + 4 * ((hz^.ipPoolMac) - 1);

  {Step through each master pointer in heap}
    mpIndex := mpFirst;
    WHILE mpIndex <= mpLast DO
        BEGIN
        mp := ORD(Handle(mpIndex)^);
        IF NOT (((mp >= mpFirst) AND (mp <= mpLast)) OR (mp = 1)) THEN  {not on the free list}
           DoToObject(POINTER(ORD(mpIndex))); { Pass it to DoToObject as a TObject, but don't coerce
                                                    directly to a TObject because of run-time checking. }
        mpIndex := mpIndex + 4;		 { advance to the next master pointer }
        END;
END;


{ ====================================== HOT UTILITIES ====================================== }




{$S sHotUtil}
FUNCTION  Min(i, j: LONGINT): LONGINT;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    IF i < j THEN
        Min := i
    ELSE
        Min := j;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sHotUtil}
FUNCTION  Max(i, j: LONGINT): LONGINT;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    IF i > j THEN
        Max := i
    ELSE
        Max := j;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sHotUtil}
PROCEDURE LatestError(newError: INTEGER; VAR previousError: INTEGER);
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    IF ((newError > 0) AND (previousError <= 0) OR
        (newError < 0) AND (previousError = 0)) THEN
       previousError := newError;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sHotUtil}
FUNCTION ClassPtr(hndl: Handle): TClass;
    VAR stp: RECORD
                CASE INTEGER OF
                    1: (asLong: LONGINT);
                    2: (asBytes: PACKED ARRAY [0..3] OF TByte);
                    3: (asClass: TClass);
                    END;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    {$IFC fMaxTrace}EP;{$ENDC}
    stp.asLong := hndl^^;
    stp.asBytes[0] := 0;
    ClassPtr := stp.asClass;
END;


{$S sUtil}
PROCEDURE LIntToHex(decNumber: LONGINT; hexNumber: TPString);
            {NOTE: hexNumber must be >= 8 characters, regardless of size of decNumber}

(* This PROCEDURE accepts a binary LONGINT, decNumber, and returns the equivalent hexadecimal *)
(* number by means of the output parameter hexNumber.  Note that if the equivalent hexadecimal number is *)
(* of a sufficiently small magnitude that it does not require all of the digits in the hex field to be *)
(* expressed (e.g. if 8 digits are allocated in the hex field and the hex number if 58A7, which is only *)
(* 4 digits), then the hexadecimal number will be right-justified with leading zeros to pad the field.  So, *)
(* for example, 58A7 will be returned as 000058A7 if 8 digits are allocated for hexadecimal numbers via the *)
(* constant hexFieldSize.   To change the number of digits in the hex field, change the constant *)
(* hexFieldSize. *)

{NOTE: many users of LIntToHex pass in a pointer to a variable declared as S8; therefore, it is important
            that LIntToHex not return more than 8 digits }

CONST
    hexFieldSize = 8;  (* the number of digits which are to appear in a hexadecimal field;  leading zeros   *)
                       (* may be used to pad small hexadecimal numbers (e.g. if hexFieldSize is 8, then the
                       (* hex number FA9 would appear as 00000FA9) *)

VAR hexDigits:  S16;		    (* a list which is to contain all hexadecimal digits *)
    i:	        1..hexFieldSize;    (* a variable for indexing individual digits of the hex number's field *)
    fudge:      INTEGER;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    hexDigits := '0123456789ABCDEF';   (* Initialize the list of hexadecimal digits *)
{$R-}hexNumber^[0] := CHR(hexFieldSize); {$IFC fRngObject}{$R+}{$ENDC}

    IF decNumber < 0 THEN
        BEGIN
        fudge := 16;		    {reverse hexDigit indexes}
        decNumber := decNumber + 1; {correct for two's complement}
        END
    ELSE
        fudge := 1;

    FOR i := hexFieldSize DOWNTO 1 DO
        BEGIN
        hexNumber^[i] := hexDigits[(decNumber MOD 16) + fudge];
        decNumber := decNumber DIV 16;
        END;
    {$IFC fMaxTrace}EP;{$ENDC}
END;   (* LIntToHex *)


{$S sUtil}
PROCEDURE LIntToStr(decNumber: LONGINT; str: TPString);
        {NOTE: str must be >= 11 characters, regardless of size of number}
    VAR neg : BOOLEAN;
        pos : INTEGER;
    BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
  {$R-} str^[0] := CHR(11); {$IFC fRngObject} {$R+} {$ENDC}

        pos := 11;
        neg := (decNumber < 0);
        decNumber := ABS (decNumber);

        REPEAT
            str^[pos] := CHR(ORD('0') + (decNumber MOD 10));
            pos := pos - 1;
            decNumber  := decNumber DIV 10;
        UNTIL decNumber = 0;

        IF neg THEN
            BEGIN
            str^[pos] := '-';
            pos := pos - 1;
            END;

        DELETE (str^, 1, pos);
    {$IFC fMaxTrace}EP;{$ENDC}
    END;


{$S sUtil}
PROCEDURE IntToStr(decNumber: INTEGER; str: TPString);
            {NOTE: str must be >= 6 characters (sign + 5 digits), regardless of size of decNumber}
    VAR s11:    STRING[11];
    BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
        LIntToStr(decNumber, @s11);
        XferLeft(Ptr(@s11), Ptr(str), Length(s11) + 1); { str length + 1 size byte }
    {$IFC fMaxTrace}EP;{$ENDC}
    END;


{$S sUtil}
PROCEDURE HexStrToLInt(hexString: TPString; VAR decNumber: LONGINT; VAR result: TConvResult);

(* This PROCEDURE accepts a STRING of hexadecimal digits, hexString, and returns a long-INTEGER decimal	 *)
(* equivalent by means of the variable parameter decNumber.  Information concerning the acceptability of *)
(* the hexadecimal STRING is returned via the variable parameter result.				 *)
(*     Note that this PROCEDURE ignores any leading or trailing blanks which may be present in the given  *)
(* hexString, and the presence of lower-case hexadecimal digits in the hex STRING does not adversely	 *)
(* affect conversion.  Also, if the first non-blank character of the STRING is a dollar sign, then that	  *)
(* dollar sign is ignored and not considered during conversion (it is, effectively, deleted from the	  *)
(* STRING).												  *)

VAR numDigits:  0..255;	   (* The number of digits in the hex STRING *)
    digit:      CHAR;
    i:	        INTEGER;   (* index variable *)
    digitValue: INTEGER;   (* index variable *)
    hexDigits:  S16;	   (* an array which is to contain a list of hexadecimal digits *)
BEGIN   (* HexStrToLInt *)
    {$IFC fMaxTrace}BP(1);{$ENDC}

      (* Delete any trailing blanks *)
    TrimBlanks(POINTER(ORD(hexstring)));

    { Remove any leading zeros, except keep at least 1 digit; also, remove any leading $ }
    IF Length(hexString^) > 0 THEN
        WHILE ((Length(hexString^) > 1) AND (hexString^[1] = '0')) OR (hexString^[1] = '$') DO
            Delete(hexString^, 1, 1);

    numDigits := Length(hexString^);

    decNumber := 0;

    IF numDigits = 0 THEN   (* if the given hex STRING is empty... *)
        result := cvNoNumber
    ELSE
    IF Length (hexString^) > 8 THEN  (* if can't fit in LONGINT *)
        result := cvOverflow
    ELSE
        result := cvValid;   (* innocent until proven guilty *)

    FOR i := 1 TO numDigits DO
        BEGIN
        digit := hexString^[i];
        IF digit IN ['0'..'9'] THEN
            digitValue := ORD(digit) - ORD('0')
        ELSE
        IF digit IN ['A'..'F'] THEN
            digitValue := ORD(digit) - ORD('A') + 10
        ELSE
        IF digit IN ['a'..'f'] THEN
            digitValue := ORD(digit) - ORD('a') + 10
        ELSE
            BEGIN
            digitValue := 0;
            result := cvBadNumber;
            END;
        decNumber := decNumber * 16 + digitValue;
        END;
    {$IFC fMaxTrace}EP;{$ENDC}
END;   (* HexStrToLInt *)


{$S sUtil}
PROCEDURE StrToLInt(str: TPString; VAR decNumber: LONGINT; VAR result: TConvResult);
    LABEL   1;

    VAR s:      S255;
        pos:    INTEGER;
        neg:    BOOLEAN;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    result := cvValid;
    XferLeft(Ptr(str), Ptr(@s), Length(str^) + 1);
    TrimBlanks(@s);

    decNumber := 0;
    neg := FALSE;

    IF s='' THEN
        result := cvNoNumber
    ELSE IF (s[1]='-') OR (s[1]='+') THEN
        BEGIN
        neg := s[1] = '-';
        Delete(s, 1, 1);
        IF s='' THEN
            result := cvBadNumber;
        END;

    pos := 1;
    WHILE pos <= Length(s) DO
        BEGIN
        IF ('0' > s[pos]) OR (s[pos] > '9') THEN {invalid numeric character}
            BEGIN
            result := cvBadNumber;
            GOTO 1;
            END;

        {check for overflow}
        IF pos > 10 THEN {more than 10 digits guarantees an overflow}
            BEGIN
            result := cvOverflow;
            GOTO 1;
            END;
        IF pos = 10 THEN
            IF ORD(s[pos]) > ORD('7') THEN
                IF decNumber > 214748363 THEN
                    BEGIN
                    result := cvOverflow;
                    GOTO 1;
                    END
                ELSE
                    { okay }
            ELSE { 10th digit is 7 or less }
                IF decNumber > 214748364 THEN
                    BEGIN
                    result := cvOverflow;
                    GOTO 1;
                    END;

        decNumber := (10 * decNumber) + (ORD(s[pos]) - ORD('0'));
        pos := pos + 1;
        END;

    IF neg THEN
        decNumber := -decNumber;
1:
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sUtil}
PROCEDURE StrToInt(str: TPString; VAR decNumber: INTEGER; VAR result: TConvResult);
    VAR l:  LONGINT;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
{$IFC fDbgObject}
{$0V+} {make sure we don't screw up}
{$ENDC}
    StrToLint(str, l, result);
    IF result = cvValid THEN
        IF (l < -MAXINT-1) OR (l > MAXINT) THEN
            result := cvOverflow
        ELSE
            decNumber := INTEGER(l);
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sUtil}
PROCEDURE TrimBlanks(str: TPString);
    LABEL
        1, 10;

    CONST
        tabCh = CHR(9);

    VAR i:      INTEGER;

BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    i := 1;
    WHILE i <= Length(str^) DO
        BEGIN
        IF str^[i] <> ' ' THEN
            IF str^[i] <> tabCh THEN
                BEGIN {delete all the leading stuff we have found}
                Delete(str^, 1, i-1);
                GOTO 1;
                END;
        i := i + 1;
        END;

    { we fell thru -- either '' or all blanks or tabs }
    str^ := '';
    GOTO 10;

1:  {now trim the trailing blanks}

    i := Length(str^);
    WHILE i > 0 DO
        BEGIN
        IF (str^[i] = ' ') OR (str^[i] = tabCh) THEN
            Delete(str^, i, 1)
        ELSE
            GOTO 10;
        i := i - 1;
        END;
10:
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sUtil}
FUNCTION  CharUpperCased(ch: CHAR): CHAR;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    CharUpperCased := ch;
    IF 'a' <= ch THEN
        IF ch <= 'z' THEN
            CharUpperCased := CHR(ORD(ch) - 32);
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sUtil}
PROCEDURE StrUpperCase(str: TPString);
    VAR i:  INTEGER;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    i := Length(str^);
    WHILE i > 0 DO
        BEGIN
        str^[i] := CharUpperCased(str^[i]);
        i := i - 1;
        END;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sUtil}
PROCEDURE SplitFilePath(VAR fullPath, itsCatalog, itsFilePart: TFilePath);
    LABEL   1;
    VAR i:  INTEGER;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    itsCatalog := '';
    itsFilePart := fullPath;

    FOR i := Length(itsFilePart) DOWNTO 1 DO
        IF itsFilePart[i] = '-' THEN
            BEGIN
            itsCatalog := COPY(itsFilePart, 1, i);
            DELETE(itsFilePart, 1, i);
            GOTO 1;
            END;
1:
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sStartup}
PROCEDURE  SetCp(object: TObject; itsClass: TClass);
    VAR index:  INTEGER;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    Handle(object)^^ := ORD(itsClass);	        {Install slice table pointer}
    index := CiOfCp(TPSliceTable(itsClass));    {Determine its class index}
    IF index < 256 THEN			        {If it will fit in a byte, store it...}
{$R-}   TPByte(Handle(object)^)^ := index;      {...to speed version conversion (cf ConvertHeap: FindClasses)}
{$IFC fRngObject}{$R+}{$ENDC}
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sStartup}
FUNCTION  NewDynObject(heap: THeap; itsClass: TClass; dynBytes: INTEGER): TObject;
    VAR nBytes: INTEGER;
        object: TObject;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    nBytes := SizeOfCp(TPSliceTable(itsClass)) + dynBytes;
    object := POINTER(ORD(HAllocate(THz(heap), nBytes)));    {TObject() won't work until after SetCp}
    IF ORD(object) = ORD(hNIL) THEN
        BEGIN
        {$IFC fDbgObject}
        WriteLn(CbOfHz(THz(heap)):1, ' bytes in the heap');
        {$ENDC}
        ABCBreak('NewObject: Heap full, can''t make an object of size', nBytes);
        END;
    SetCp(object, itsClass);
    NewDynObject := object;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sStartup}
FUNCTION  NewObject(heap: THeap; itsClass: TClass): TObject;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    NewObject := NewDynObject(heap, itsClass, 0);
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sStartup}
PROCEDURE ResizeDynObject(object: TObject; newTotalBytes: INTEGER);
    VAR i: INTEGER;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    IF (newTotalBytes < 0) OR (newTotalBytes > (MAXINT-20)) THEN
        ABCBreak('New size must lie between 0 and 32K-20, not', newTotalBytes);
    ChangeSizeH(THz(object.Heap), TH(object), newTotalBytes);
    IF CbDataOfH(THz(object.Heap), TH(object)) < newTotalBytes THEN
       ABCBreak('ResizeDynObject: Heap full, size can''t change to', newTotalBytes);
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$IFC compatibileLists}
FUNCTION  SubObject(super: TObject; itsClass: TClass): TObject;
BEGIN
    ResizeDynObject(super, SizeOfCp(TPSliceTable(itsClass)));
    SetCP(super, itsClass);
    SubObject := super;
END;
{$ENDC}


{$S sStartup}
FUNCTION  NewOrRecycledObject(heap: THeap; itsClass: TClass; VAR chainHead: TObject): TObject;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    IF chainHead = NIL THEN
        NewOrRecycledObject := NewObject(heap, itsClass)
    ELSE
        BEGIN
        {$IFC fDbgObject}
        IF (chainHead.Class <> itsClass) OR (chainHead.Heap <> heap) THEN
            ABCBreak('NewOrRecycledObject: chainHead contains an alien object', ORD(chainHead));
        {$ENDC}
        NewOrRecycledObject := chainHead;
        chainHead := THRecycleChain(chainHead)^^.chainLink;
        END;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sStartup}
PROCEDURE RecycleObject(object: TObject; VAR chainHead: TObject);
    {$IFC fDbgObject}
    VAR chainMember: TObject;
    {$ENDC}
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    {$IFC fDbgObject}
    IF object.HeapBytes < 8 THEN
        ABCBreak('RecycleObject: object is too small for a chainHead link', ORD(object));
    chainMember := chainHead;
    WHILE chainMember <> NIL DO
        BEGIN
        IF chainMember = object THEN
            ABCBreak('RecycleObject: object freed twice', ORD(object));
        chainMember := THRecycleChain(chainMember)^^.chainLink;
        END;
    {$ENDC}
    THRecycleChain(object)^^.chainLink := chainHead;
    chainHead := object;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sRes}
PROCEDURE Recreate(object: TObject; oldSize, newSize: INTEGER; newSTP: TPSliceTable);
    VAR extraPtr:   TPByte;
        hz:	    THz;
        cb:	    INTEGER;
        bk:	    LONGINT;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    SetCP(object, TClass(newSTP));      {Install the new slice-table pointer}
    IF newSize <> oldSize THEN	        {Default extra fields to 0/NIL}
        BEGIN
        hz := HzFromH(TH(object));
        cb := CbDataOfH(hz, TH(object));
        bk := ORD(Handle(object)^);

        IF (cb > oldSize) AND (newSize < oldSize) THEN	  {There is a variable-length part & we're shrinking}
            XferLeft(Ptr(bk + oldSize), Ptr(bk + newSize), cb - oldSize);

        ChangeSizeH(hz, TH(object), cb + newSize - oldSize);

        IF (cb > oldSize) AND (newSize > oldSize) THEN	  {There is a variable-length part & we're expanding}
            XferRight(Ptr(bk + oldSize), Ptr(bk + newSize), cb - oldSize);

        IF newSize > oldSize THEN       {Default extra fields to 0/NIL}
            BEGIN
            extraPtr := TPByte(bk + oldSize + 1);
            extraPtr^ := 0;	    {Store one zero and let XferLeft copy it repeatedly}
            XferLeft(Ptr(extraPtr), Ptr(ORD(extraPtr) + 1), newSize - oldSize - 1);
            END;
        END;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sRes}
FUNCTION  Superclass(class: TClass): TClass;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
{$R-} Superclass := TClass(TPSliceTable(class)^[-1]); {$IFC fRngObject}{$R+}{$ENDC}
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sRes}
FUNCTION  ClassDescendsFrom(descendant, ancestor: TClass): BOOLEAN;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    WHILE (descendant <> ancestor) AND (descendant <> NIL) DO
        {$R-} descendant := TClass(TPSliceTable(descendant)^[-1]); {$IFC fRngObject}{$R+}{$ENDC}
    ClassDescendsFrom := descendant <> NIL;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sRes}
PROCEDURE NameOfClass(class: TClass; VAR className: TClassName);
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    CpToCn(TPSliceTable(class), TS8(className));
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sRes}
FUNCTION  SizeOfClass(class: TClass): INTEGER;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    SizeOfClass := SizeOfCp(TPSliceTable(class));
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S SgCLAres}
    {toInsert, return: -1 if class already there or if table full, index if a hole found}
    {not toInsert, return: index (> 0) if class found, -1 if not there}
FUNCTION LookupName(classAlpha: TA8; toInsert: BOOLEAN): INTEGER;

    FUNCTION CompareName(hashIndex: INTEGER): THashCompare;
        VAR myIndex:    INTEGER;
            trialName:  TS8;
    BEGIN
        myIndex := hMyHashName^^.records[hashIndex];
        IF myIndex = 0 THEN
            CompareName := cHole
        ELSE
        IF classAlpha = hMyClasses^^.records[myIndex].classAlpha THEN
            CompareName := cMatch
        ELSE
            CompareName := cMismatch;
    END;

BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    {$IFC fMaxTrace}EP;{$ENDC}
    LookupName := LookupInHashArray(hMyHashName^^.header.size,
                                    ORD(classAlpha[2])*ORD(classAlpha[4])+ORD(classAlpha[6]),
                                    toInsert, CompareName);
END;


{$S SgCLAres}
FUNCTION  ValidDataAddress(addr: LONGINT): BOOLEAN;
          {Returns TRUE iff: addr is in a data segment (stack seg doesn't qualify)
                    AND is it an even address
                    AND is it within the bounds of the data segment}

    CONST   dsMaxSize   = $00020000; {128K}

    VAR error:  INTEGER;
        refnum: INTEGER;
        dsInfo: dsInfoRec;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    ValidDataAddress := FALSE;

    IF NOT ODD(addr) THEN
        BEGIN
        Info_Address(error, addr, refnum);
        IF error <= 0 THEN
            BEGIN
            Info_Dataseg(error, refnum, dsInfo);
            IF error <= 0 THEN
                IF (addr MOD dsMaxSize) < dsInfo.mem_size THEN
                    ValidDataAddress := TRUE;
            END;
        END;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sStartup}
PROCEDURE Free(object: TObject);
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    IF object <> NIL THEN
        object.Free;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{*** THE FOLLOWING TWO ROUTINES ASSUME THAT THE hHashName AND hMyClasses TABLES ARE ALWAYS AROUND ***}
        {*** IF THEY START SWAPPING OUT, WRITE LINEAR SEARCH ROUTINES TO REPLACE THESE ***}


{$S SgCLAres}
FUNCTION CiOfAlpha(classAlpha: TA8): INTEGER;	    {convert class title TA8 to class index}
    VAR hashIndex:  INTEGER;
        i:	    INTEGER;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    hashIndex := LookupName(classAlpha, FALSE);
    IF hashIndex <= 0 THEN
        CiOfAlpha := 0
    ELSE
        CiOfAlpha := hMyHashName^^.records[hashIndex];
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S SgCLAres}
FUNCTION CiOfCn(className: S8): INTEGER;	    {convert upper-case class title S8 to class index}
    VAR a8: TA8;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    FillChar(a8, 8, ' ');
    XferLeft(Ptr(ORD(@className)+1), @a8, Length(className));
    CiOfCn := CiOfAlpha(a8);
    {$IFC fMaxTrace}EP;{$ENDC}
END;



{ ====================================== INITIALIZATION ====================================== }


{$S sError}

PROCEDURE CheckInitError(error: INTEGER);
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    IF error > 0 THEN {Can only call with error > 0 before TProcess class-init has run}
        InitErrorAbort(error);
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sInit1}
FUNCTION  NewHeap(VAR error: INTEGER; heapStart, numBytes: LONGINT; numObjects: INTEGER): THeap;
    VAR heap:	    THeap;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    heap := THeap(HzInit(POINTER(heapStart), POINTER(heapStart+numBytes),
                                         NIL, numObjects, 0, POINTER(procNil),
                                         POINTER(procNil), POINTER(procNil), POINTER(procNil)));
    IF heap = POINTER(1) THEN
        BEGIN
        error := erInternal;
        ABCBreak('NewHeap could not make a heap of size', numBytes);
        heap := NIL;
        END
    ELSE
        error := 0;

    NewHeap := heap;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sInit1}
FUNCTION  MakeDataSegment(VAR error, dsRefnum: INTEGER; firstTryVolume, thenTryVolume: TFilePath;
                               ldsn, memBytes, diskBytes: INTEGER): LONGINT;
    VAR startAddress:  LONGINT;

    PROCEDURE TryMakeDataSegment(volumePart: TFilePath);
        VAR dsPathname: PathName;
    BEGIN
        dsPathname := Concat(volumePart, 'ds_private');
        Make_Dataseg(error, dsPathname, memBytes, diskBytes, dsRefnum, startAddress, ldsn, ds_private);
    END;

BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    TryMakeDataSegment(firstTryVolume);
    IF error = 309 THEN
        IF firstTryVolume <> thenTryVolume THEN
            TryMakeDataSegment(thenTryVolume);

    IF error >0 THEN
        BEGIN
        ABCBreak('MakeDataSegment', error);
        startAddress := 0;
        END;
    MakeDataSegment := startAddress;
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S sInit1}
PROCEDURE InitObject;
    VAR dsp:	        DsProcParam;
        excepName:      T_Ex_Name;
        error:	        INTEGER;
        prcsInfo:       ProcInfoRec;
        heapBase:       LONGINT;
        progVolume:     PathName;
BEGIN
  {Until we call InitQDWM, NOTHING CAN FAIL!!!!}

    isInitialized := FALSE;     {An interface variable set true at a higher level: e.g., by TProcess.Run}
    amDying := FALSE;	        {An interface variable set true at a higher level when ImDying is called}
    wmIsInitialized := FALSE;   {An interface variable set true at a higher level: e.g., by InitQDWM}

    {$IFC fTrace}
    fTraceEnabled := FALSE;
    fDebugRecursion := FALSE;
    tabLevel := -1;
    curTraceLevel := 1;
    traceCount := 0;
    defTraceCount := 0;
    breakMCount := 0;
    kpcntr := 0;
    keyPresLimit := stdKeyPresLimit;
    returnToMain := TRUE;
    showPrompt := TRUE;
    outputIndent := 0;
    currXPos := 0;
    tallyingCalls := FALSE;
    tallies := NIL;
    segNames := NIL;
    {$ENDC}

  {Determine environment and program volume name}
    Info_Process(error, My_id, prcsInfo);

    {get my volume name as '-volname-'; assumes that the OS gives us back a program name of the form:
                                            '-volname-progname'}
    Delete(prcsInfo.progPathName, 1, 1); {the first '-'}
    progVolume := Concat('-', Copy(prcsInfo.progPathName, 1, Pos('-', prcsInfo.progPathName)));


{$IFC LibraryVersion <= 20}
  {Yu Ying has a better way to know if we are on the desktop or in the workshop, but meanwhile...}
    IF prcsInfo.father_Id > 1 THEN
        BEGIN
        Info_Process(error, prcsInfo.father_Id, prcsInfo);

        {this assumes that the OS returns a program name of the form '-volname-progname'}
        Delete(prcsInfo.progPathName, 1, 1); {the first '-'}
        Delete(prcsInfo.progPathName, 1, Pos('-', prcsInfo.progPathName)); {the 'volname-'}
        StrUpperCased(@prcsInfo.progPathName);

        onDesktop := prcsInfo.progPathName = 'SHELL.OFFICE SYSTEM';
        END
    ELSE
        BEGIN
        onDesktop := FALSE;
        END;
{$ELSEC}
    dsp.procCode := dsGetDiskEnbF;
    DSPaslibCall(dsp);
    onDesktop := NOT dsp.diskEnbF;
{$ENDC}

    InitQDWM;   {must be the first thing before any operations that could fail;
                    when running on the Workshop, it also sets up the FontMgr & writeln to alternate screen.}

    {$IFC fDbgObject}
    Write('Running on the ');
    IF onDesktop THEN
        WriteLn('desktop')
    ELSE
        WriteLn('workshop');
    {$ENDC}

  {Declare an OS Exception Handler}
    excepName := 'SYS_TERMINATE';
    Declare_Excep_Hdl(error, excepName, @TrmntExceptionHandler);
    CheckInitError(error);

    {$IFC fDbgObject}
    GoToXY(0,31);
    {$ENDC}

  {Create data segment and heap}
    mainLdsn := prcsLdsn;
    heapBase := MakeDataSegment(error, mainDsRefnum, '', progVolume, mainLdsn, prcsDsBytes, prcsDsBytes);
    CheckInitError(error);

    mainHeap := NewHeap(error, heapBase, prcsDsBytes, prcsDsBytes DIV 20);
    CheckInitError(error);

    SetHeap(mainHeap);
END;


{$S sInit1}
PROCEDURE UnitAuthor(companyAndAuthor: TAuthorName);			      {required once per unit}
    VAR a32:   TA32;
BEGIN
    StrUpperCased(@companyAndAuthor);
    FillChar(a32, 32, ' ');
    XferLeft(Ptr(ORD(@companyAndAuthor)+1), @a32, LENGTH(companyAndAuthor));
    QUnitAuthor(a32);
END;


{$S sInit1}
PROCEDURE ClassAuthor(companyAndAuthor: TAuthorName; classAlias: TClassName);	     {optional}
    VAR a32:   TA32;
        a8:    TA8;
BEGIN
    IF LENGTH(companyAndAuthor) > 0 THEN
        BEGIN
        StrUpperCased(@companyAndAuthor);
        FillChar(a32, 32, ' ');
        XferLeft(Ptr(ORD(@companyAndAuthor)+1), @a32, LENGTH(companyAndAuthor));
        QClassAuthor(a32);
        END;

    IF LENGTH(classAlias) > 0 THEN
        BEGIN
        StrUpperCased(@classAlias);
        FillChar(a8, 8, ' ');
        XferLeft(Ptr(ORD(@classAlias)+1), @a8, LENGTH(classAlias));
        QClassAlias(a8);
        END;
END;


{$S sInit1}
PROCEDURE ClassVersion(itsVersion, oldestItCanRead: Byte);	       {optional}
BEGIN
    IF (itsVersion < 0) OR (itsVersion > 127) OR (oldestItCanRead < 0) OR (oldestItCanRead > 127) OR
        (oldestItCanRead > itsVersion) THEN
            ABCBreak('Version numbers must be in the range 0..127 and oldestItCanRead <= itsVersion',
                     itsVersion);
    QClassVersion(itsVersion, oldestItCanRead);
END;


{ ====================================== VERSION CONVERSION ====================================== }


{$S SgCLAcld}
PROCEDURE ConvClass(object: TObject; exWorld: TWorld; exIndex, myIndex: INTEGER);
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    Recreate(object, exWorld.hExClasses^^.records[exIndex].objectSize, (*^*)
        hMyClasses^^.records[myIndex].objectSize, hMySTables^^.records[myIndex]); (*^*)
    {$IFC fMaxTrace}EP;{$ENDC}
END;


{$S SgCLAcld}
FUNCTION IndexOfExClass(exWorld: TWorld; exIndex: INTEGER): INTEGER;
    LABEL 1,2;
    VAR exAuthor:   TA32;
        exAlias:    TA8;
        exAlpha:    TA8;
        coCode:	    INTEGER;
        alCode:	    INTEGER;
        index:	    INTEGER;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    {$IFC fMaxTrace}EP;{$ENDC}
    IndexOfExClass := 0;

    WITH exWorld, hExClasses^^.records[exIndex] DO (*^*)(* WHOLE BLOCK CHANGED *)
        BEGIN
        exAlpha := classAlpha;

        IF classAlias = 0 THEN
            exAlias := classAlpha
        ELSE
            exAlias := hExAliases^^.records[classAlias];

        IF companyAndAuthor <> 0 THEN
            BEGIN
            exAuthor := hExAuthors^^.records[companyAndAuthor];
            WITH hMyAuthors^^ DO
                FOR coCode := 1 TO numAuthors DO
                    IF records[coCode] = exAuthor THEN (*^*)
                        GOTO 1;
            END;
        coCode := 0;
  1:
        END;

    {If that class name is in my alias list, do it the hard way}
    WITH hMyAliases^^ DO
        FOR alCode := 1 TO numAliases DO
            IF records[alCode] = exAlias THEN
                GOTO 2;

    {If that class name is one of mine, too, do it the easy way}
    index := CiOfAlpha(exAlpha);
    IF index <> 0 THEN (*^*)
        IF hMyClasses^^.records[index].companyAndAuthor = coCode THEN
            BEGIN (*^*)
            IndexOfExClass := index;
            EXIT(IndexOfExClass); (*^*)
            END; (*^*)

    {Different company name or never heard of that class name at all, return 0}
    EXIT(IndexOfExClass); (*^*)

  2:
    {The hard way: exhaustive search, because we may be using different names for the same class}
    WITH hMyClasses^^ DO
        FOR index := 1 TO numClasses DO
            WITH records[index] DO
                IF coCode = companyAndAuthor THEN
                    IF alCode = classAlias THEN
                        BEGIN
                        IndexOfExClass := index;
                        EXIT(IndexOfExClass);
                        END;
END;


{$S SgCLAcld}
FUNCTION  NeedConversion(exClassWorld: TClassWorld; VAR olderVersion, newerVersion: BOOLEAN): BOOLEAN;
    VAR someDifference:	    BOOLEAN;
        exWorld:	    TWorld;
        numExClasses:	    INTEGER;
        exIndex:	    INTEGER;
        exInfo:		    TClassInfo;
        exSize:		    INTEGER;
        exSTP:		    TPSliceTable;
        myIndex:	    INTEGER;
        myInfo:		    TClassInfo;
        mySize:		    INTEGER;
        mySTP:		    TPSliceTable;
BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    {$IFC fMaxTrace}EP;{$ENDC}
    someDifference := FALSE;
    olderVersion := FALSE;
    newerVersion := FALSE;

    exWorld := TWorld(exClassWorld);	    {Separate statement because of a compiler bug}
    WITH exWorld DO
        BEGIN
        numExClasses := hExClasses^^.header.size;

        IF numClasses <> numExClasses THEN
            someDifference := TRUE;

        FOR exIndex := 1 TO numExClasses DO
            BEGIN
            myIndex := IndexOfExClass(exWorld, exIndex);
            IF myIndex = 0 THEN
                newerVersion := TRUE
            ELSE
                BEGIN
                exInfo := hExClasses^^.records[exIndex];
                exSize := exInfo.objectSize;
                exSTP := hExSTables^^.records[exIndex];

                myInfo := hMyClasses^^.records[myIndex];
                mySize := myInfo.objectSize;
                mySTP := hMySTables^^.records[myIndex];

                IF (myInfo.version < exInfo.version) OR (mySize < exSize) THEN
                    newerVersion := TRUE;

                IF (myInfo.version > exInfo.version) OR (mySize > exSize) THEN
                    olderVersion := TRUE;

                IF (mySTP <> exSTP) OR (myInfo.oldestReadableVersion <> exInfo.oldestReadableVersion) THEN
                    someDifference := TRUE;

                IF exInfo.superIndex = 0 THEN
                    BEGIN
                    IF myInfo.superIndex <> 0 THEN
                        newerVersion := TRUE;
                    END
                ELSE
                IF myInfo.superIndex <> IndexOfExClass(exWorld, exInfo.superIndex) THEN
                    newerVersion := TRUE;
                END;
            END;
        END;

    NeedConversion := someDifference OR olderVersion OR newerVersion;
END;


{$S SgCLAcld}
PROCEDURE ConvertHeap(heap: THeap; exClassWorld: TClassWorld);

    {*** VERSION CONVERSION ***
     Convert all the contents of heap from its classes to ours.
     The job is done in two passes through heap:
        (1) ConvertClass changes the method-table pointer of each object, and may change its size.
            If the object grows, extra fields are defaulted to 0/NIL.
        (2) ConvertFields tells each object to "Convert(oldVersion)", thus giving the application a
                chance to calculate extra fields or otherwise modify the converted object.}

    VAR exWorld:        TWorld;
        needPassTwo:    BOOLEAN;
        numExClasses:   INTEGER;
        hExHashSTP:     THIdxArray;
        hExEquivalent:  THIdxArray;
        exIndex:        INTEGER;

        {toInsert, return: -1 if sliceTable already there or if table full, index if a hole found}
        {not toInsert, return: index (> 0) if sliceTable found, -1 if not there}
    FUNCTION LookupSTP(stp: TPSliceTable; toInsert: BOOLEAN): INTEGER;

        FUNCTION CompareSTP(hashIndex: INTEGER): THashCompare;
            VAR myIndex:   INTEGER;
        BEGIN
            myIndex := hExHashSTP^^.records[hashIndex];
            IF myIndex = 0 THEN
                CompareSTP := cHole
            ELSE
            IF exWorld.hExSTables^^.records[myIndex] = stp THEN
                CompareSTP := cMatch
            ELSE
                CompareSTP := cMismatch;
        END;

    BEGIN
        LookupSTP := LookupInHashArray(hExHashSTP^^.header.size, ORD(stp), toInsert, CompareSTP);
    END;

    FUNCTION EquivIndex(exIndex: INTEGER): INTEGER;
        VAR tblIndex:	    INTEGER;
            myIndex:	    INTEGER;
    BEGIN
        tblIndex := exIndex;

        WITH exWorld DO
            WHILE tblIndex <> 0 DO
                WITH hExClasses^^.records[tblIndex] DO
                    BEGIN
                    myIndex := IndexOfExClass(exWorld, tblIndex);
                    IF myIndex <> 0 THEN
                        IF version >= hMyClasses^^.records[myIndex].oldestReadableVersion THEN
                            BEGIN
                            EquivIndex := myIndex;
                            EXIT(EquivIndex);
                            END;
                    tblIndex := superIndex;
                    END;

        {$IFC fDbgObject}
        ABCBreak('No common superclass', exIndex);
        {$ENDC}
        EquivIndex := 0;
    END;

    FUNCTION FindClasses(object: TObject; VAR exIndex, myIndex: INTEGER; VAR moreConversion: BOOLEAN)
                        : BOOLEAN;
        {Given an object, return the original and my class index}
        VAR stp:	    TPSliceTable;
            pStp:	    ^TPSliceTable;(*^*)
            exHashIndex:    INTEGER;
            exVersion:	    INTEGER;
            exSize:	    INTEGER;
    BEGIN
        FindClasses := FALSE;
      {Determine the original class of the object from its method table ptr}
        stp := TPSliceTable(Handle(object)^^);

(*^*)
      {Obtain access to its high byte}
        pStp := @stp;

      {stp probably has its exIndex stored in its high byte (unless > 255 or not a Clascal object)}
        exIndex := TPByte(pStp)^;
        TPByte(pStp)^ := 0;		    {So the stp comparisons below will be uncluttered}

        IF exIndex < 0 THEN
            exIndex := 256 + exIndex;	    {Undo sign extension caused by TPByte^}

        IF exIndex <> 0 THEN		    {It might be a class pointer}
            IF exIndex > numExClasses THEN
                exIndex := 0		    {Not a real class pointer}
            ELSE			    {Could not use "WITH exWorld" here because code generator balked}
            IF exWorld.hExSTables^^.records[exIndex] <> stp THEN
                exIndex := 0;		    {Not a real class pointer}
(*^*){Also added next 3 comments below}

        IF exIndex = 0 THEN		    {It is not a class pointer, or exIndex>255}
            IF numExClasses > 255 THEN	    {It might be a class pointer after all}
                BEGIN			    {Look in the hash table}
                exHashIndex := LookupSTP(stp, FALSE);
                IF exHashIndex <= 0 THEN    {Not a Clascal object}
                    Exit(FindClasses);
                exIndex := hExHashSTP^^.records[exHashIndex];
                END
            ELSE
                Exit(FindClasses); {not a Clascal object}

      {Determine the equivalent class in my process}
        myIndex := hExEquivalent^^.records[exIndex];
        FindClasses := TRUE;
        WITH exWorld.hExClasses^^.records[exIndex] DO
            BEGIN
            exVersion := version;
            exSize := objectSize;
            END;

        WITH hMyClasses^^.records[myIndex] DO
            moreConversion := (exVersion < version) OR (exSize < objectSize);

(**** Replaced the following line by the preceding because it is too complicated for the
            Spring Release code generator:

        WITH exWorld.hExClasses^^ DO
            moreConversion := (records[exIndex].version < hMyClasses^^.records[myIndex].version) OR
                              (records[exIndex].objectSize < hMyClasses^^.records[myIndex].objectSize);
****)
     END;

    PROCEDURE ConvertClass(object: TObject);
        {Pass 1: Map the method-table ptr from the original to mine and change the object size}
        VAR exIndex:	    INTEGER;
            myIndex:	    INTEGER;
            moreConverson:  BOOLEAN;
    BEGIN
      {Determine both the original and my class}
        IF FindClasses(object, exIndex, myIndex, moreConversion) THEN
            BEGIN
          {Convert the method table pointer, change the size, default extra fields to 0/NIL}
            ConvClass(object, exWorld, exIndex, myIndex);
            IF moreConversion THEN {a second pass will be needed to let the app do special defaulting}
                needPassTwo := TRUE;
            END;
    END;

    PROCEDURE ConvertFields(object: TObject);
        {Pass 2: Default extra fields; a separate pass so the application can follow pointers if need be}
        VAR exIndex:	    INTEGER;
            myIndex:	    INTEGER;
            moreConverson:  BOOLEAN;
    BEGIN
      {Determine both the original and my class}
        IF FindClasses(object, exIndex, myIndex, moreConversion) THEN
            IF moreConversion THEN   {Let the app supply extra fields etc.}
                object.Convert(exWorld.hExClasses^^.records[exIndex].version);
    END;

BEGIN
    {$IFC fMaxTrace}BP(1);{$ENDC}
    {$IFC fMaxTrace}EP;{$ENDC}
    exWorld := TWorld(exClassWorld);
    WITH exWorld DO
        BEGIN
        numExClasses := hExClasses^^.header.size;

      {Make temporary arrays that will speed up reconciliation of the two worlds}
        hExEquivalent := MakeIdxArray(numExClasses, FALSE);
        FOR exIndex := 1 TO numExClasses DO
            hExEquivalent^^.records[exIndex] := EquivIndex(exIndex);
        IF numExClasses > 255 THEN
            BEGIN
            hExHashSTP := MakeIdxArray(numExClasses - 255, TRUE);
            FOR exIndex := 256 TO numExClasses DO
                hExHashSTP^^.records[LookupSTP(hExSTables^^.records[exIndex], TRUE)] := exIndex;
            END;
        END;

    needPassTwo := FALSE;
  {Pass One -- convert method table pointers (STPs)}
    EachObject(heap, ConvertClass);
  {Pass Two -- let application default extra fields}
    IF needPassTwo THEN
        EachObject(heap, ConvertFields);

  {Free the temporary arrays}
    FreeH(THz(mainHeap), TH(hExEquivalent));
    IF numExClasses > 255 THEN (*^*)
        FreeH(THz(mainHeap), TH(hExHashSTP));
END;


{$S sError}
PROCEDURE ClascalReason(error: INTEGER; VAR s: S255);
BEGIN
    CASE error OF
        OTHERWISE s := 'Some kind of problem';	    {** Need more cases **}
        END;
END;


{$S sInit1}
PROCEDURE ClascalError(error: INTEGER); {called with error = 0 after successful Clascal initialization}
    VAR s:  S255;
        i:  INTEGER;
BEGIN
    IF error > 0 THEN
        BEGIN
        {$IFC fDbgObject}
        ClascalReason(error, s);
        {$ENDC}
        IF isInitialized THEN
            BEGIN
            {$IFC fDbgObject}
            ABCBreak(s, error);
            {$ENDC}
            TrmntExceptionHandler;
            END
        ELSE
            BEGIN
            {$IFC fDbgObject}
            WriteLn('Clascal error: ', s);
            {$ENDC}
            IF wmIsInitialized THEN
                InitErrorAbort(error)
            ELSE
            {$IFC fDbgObject}
                %_GoLisaBug;
            {ELSEC}
                HALT;
            {$ENDC}
            END;
        END
    ELSE
    IF NOT classesInitialized THEN
        BEGIN
      {*** STILL TO DO: The first time the program runs, write to the tool resource file ***}

        {Save conversion information not obtainable from UClascal in permanent arrays}

(*****
        hMyClasses := THClasses(TDynamicArray.CREATE(NIL, mainHeap, SIZEOF(TClassInfo), numClasses));
        XferLeft(Ptr(pClasses), @hMyClasses^^.records, numClasses * SIZEOF(TClassInfo));

        hMySTables := THSTables(TDynamicArray.CREATE(NIL, mainHeap, SIZEOF(TPSliceTable), numClasses));
        XferLeft(Ptr(pSTables), @hMySTables^^.records, numClasses * SIZEOF(TPSliceTable));

        hMyAuthors := THAuthors(TDynamicArray.CREATE(NIL, mainHeap, SIZEOF(TA32), numAuthors));
        XferLeft(Ptr(pAuthors), @hMyAuthors^^.records, numAuthors * SIZEOF(TA32));

        hMyAliases := THAliases(TDynamicArray.CREATE(NIL, mainHeap, SIZEOF(TA8), numAliases));
        XferLeft(Ptr(pAliases), @hMyAliases^^.records, numAliases * SIZEOF(TA8));
*****)

        hMyClasses := THClasses(TArray.CREATE(NIL, mainHeap, numClasses, SIZEOF(TClassInfo)));
        TArray(hMyClasses).EditAt(1, numClasses);
        XferLeft(Ptr(pClasses), @hMyClasses^^.records, numClasses * SIZEOF(TClassInfo));

        hMySTables := THSTables(TArray.CREATE(NIL, mainHeap, numClasses, SIZEOF(TPSliceTable)));
        TArray(hMySTables).EditAt(1, numClasses);
        XferLeft(Ptr(pSTables), @hMySTables^^.records, numClasses * SIZEOF(TPSliceTable));

        hMyAuthors := THAuthors(TArray.CREATE(NIL, mainHeap, numAuthors, SIZEOF(TA32)));
        TArray(hMyAuthors).EditAt(1, numAuthors);
        XferLeft(Ptr(pAuthors), @hMyAuthors^^.records, numAuthors * SIZEOF(TA32));

        hMyAliases := THAliases(TArray.CREATE(NIL, mainHeap, numAliases, SIZEOF(TA8)));
        TArray(hMyAliases).EditAt(1, numAliases);
        XferLeft(Ptr(pAliases), @hMyAliases^^.records, numAliases * SIZEOF(TA8));

        WITH myWorld DO
            BEGIN
            infRecs := TArray(hMyClasses);  {&&& field names are a bit confusing}
            classes := TArray(hMySTables);
            authors := TArray(hMyAuthors);
            aliases := TArray(hMyAliases);
            END;

        hMyHashName := MakeIdxArray(numClasses, TRUE);
        FOR i := 1 TO numClasses DO
            hMyHashName^^.records[LookupName(hMyClasses^^.records[i].classAlpha, TRUE)] := i;
        END;
END;


{ ====================================== METHODS OF CLASSES ====================================== }




METHODS OF TObject;


{$S sStartup}
    PROCEDURE TObject.Become(object: TObject);
        LABEL   1;

        VAR hSelf:  TH;
            hObj:   TH;
            bkSelf: TBk;
            bkObj:  TBk;
            p:	    TP;
{$IFC LibraryVersion <= 20}
            oh:	    TC;
{$ELSEC}
            tempBP: TBp;
{$ENDC}
    BEGIN
        {$IFC fTrace}BP(4);{$ENDC}
        IF SELF.Heap <> object.Heap THEN
            BEGIN
            {$IFC fDbgObject}
            WriteLn(ORD(SELF));
            ABCBreak('Attempt to Become an object on another heap', ORD(object));
            {$ENDC}
            GOTO 1;
            END;

        hSelf := TH(SELF);
        hObj := TH(object);

        bkSelf := TBk(ORD(hSelf^) - 4);
        bkObj := TBk(ORD(hObj^) - 4);

        p := hSelf^;
        hSelf^ := hObj^;
        hObj^ := p;

{$IFC LibraryVersion <= 20}
        oh := bkSelf^.oh;
        bkSelf^.oh := bkObj^.oh;
        bkObj^.oh := oh;
{$ELSEC}
        tempBP := bkSelf^.bp;
        bkSelf^.bp := bkObj^.bp;
        bkObj^.bp := tempBP;
{$ENDC}

        object.Free;
1:
        {$IFC fTrace}EP;{$ENDC}
    END;


{$S sStartup}
    FUNCTION  TObject.Class: TClass;
    BEGIN
        {$IFC fMaxTrace}BP(1);{$ENDC}
        Class := ClassPtr(Handle(SELF));
        {$IFC fMaxTrace}EP;{$ENDC}
    END;


{$S sRes}
    FUNCTION  TObject.Clone(heap: THeap): TObject;
    BEGIN
        {$IFC fMaxTrace}BP(1);{$ENDC}
        Clone := SELF.CloneObject(heap);
        {$IFC fMaxTrace}EP;{$ENDC}
    END;


{$S sRes}
    FUNCTION  TObject.CloneObject(heap: THeap): TObject;
        VAR hz:	    THz;
            size:   INTEGER;
            source: TH;
            dest:   TH;
    BEGIN
        {$IFC fTrace}BP(2);{$ENDC}
        hz := THz(heap);
        source := TH(SELF);
        size := cbDataOfH(hz, source);
        dest := HAllocate(hz, size);
        XferLeft(@source^^, @dest^^, size);
        CloneObject := TObject(dest);
        {$IFC fTrace}EP;{$ENDC}
    END;


{$S sStartup}
    PROCEDURE TObject.Free;
    BEGIN
        {$IFC fTrace}BP(3);{$ENDC}
        SELF.FreeObject;
        {$IFC fTrace}EP;{$ENDC}
    END;


{$S sStartup}
    PROCEDURE TObject.FreeObject;
        VAR heap:       THeap;
            numObjects: INTEGER;
    BEGIN
        {$IFC fTrace}BP(4);{$ENDC}
        heap := SELF.Heap;
        FreeH(THz(heap), TH(SELF));
        {$IFC fTrace}EP;{$ENDC}
    END;


{$S sStartup}
    FUNCTION  TObject.Heap: THeap;
    BEGIN
        {$IFC fMaxTrace}BP(1);{$ENDC}
        {$IFC fMaxTrace}EP;{$ENDC}
        Heap := THeap(HzFromH(TH(SELF)));
    END;


{$S sRes}
    FUNCTION  TObject.HeapBytes: INTEGER;
    BEGIN
        {$IFC fTrace}BP(2);{$ENDC}
        HeapBytes := CbDataOfH(HzFromH(TH(SELF)), TH(SELF));
        {$IFC fTrace}EP;{$ENDC}
    END;


{$S sLOX}
    PROCEDURE TObject.Read(s: TStringScanner);
    BEGIN
        {$IFC fTrace}BP(2);{$ENDC}
        s.XferFields(xRead, SELF);
        {$IFC fTrace}EP;{$ENDC}
    END;


{$S sLOX}
    PROCEDURE TObject.Write(s: TStringScanner);
    BEGIN
        {$IFC fTrace}BP(2);{$ENDC}
        s.XferFields(xWrite, SELF);
        {$IFC fTrace}EP;{$ENDC}
    END;


    {$IFC fDebugMethods}
    {$S SgCLAdbg}
    PROCEDURE TObject.Debug(numLevels: INTEGER; memberTypeStr: S255);
        VAR class:      TClass;
            name:       TClassName;
            str:        S255;
            {$IFC fTrace}
            oldFlag:    BOOLEAN;
            {$ENDC}

        PROCEDURE SupplyObjFields(PROCEDURE Field(nameAndType: S255));
        BEGIN
            SELF.Fields(Field);
        END;

    BEGIN
        {$IFC fTrace}
        oldFlag	 := fDebugRecursion;
        fDebugRecursion := TRUE;
        {$ENDC}

        class := SELF.Class;
        CpToCn(TPSliceTable(class), TS8(name));
        TrimBlanks(@name);
        WrStr(Concat(name, ' '));

        {$IFC fDebugMethods}
        IF numLevels > 0 THEN
            WriteDRecord(numLevels, Handle(SELF), 4, SupplyObjFields);  {4 skips method table ptr}
        {$ELSEC}
        LIntToHex(ORD(SELF), @str);
        str := Concat('-- $', str);
        IF NOT ValidObject(Handle(SELF)) THEN
            str := Concat('Invalid Object', str);
        WrStr(str);
        {$ENDC}

        {$IFC fTrace}
        fDebugRecursion := oldFlag;
        {$ENDC}
    END;
    {$S SgCLAres}
    {$ENDC}


    {$IFC fDebugMethods}
    {$S SgCLAdbg}
    PROCEDURE TObject.Fields(PROCEDURE Field(nameAndType: S255));
    BEGIN
    END;
    {$S SgCLAres}
    {$ENDC}


    {$S SgCLAcld}
    PROCEDURE TObject.Convert(fromVersion: Byte);
    BEGIN
        {$IFC fMaxTrace}BP(1);{$ENDC}
        {$IFC fMaxTrace}EP;{$ENDC}
    END;
    {$S SgCLAres}


    {$S SgCLAcld}
    FUNCTION  TObject.JoinClass(newClass: TClass): TObject;
        VAR oldClass:   TClass;
    BEGIN
        {$IFC fTrace}BP(7);{$ENDC}
        oldClass := SELF.Class;
        IF NOT ClassDescendsFrom(oldClass, newClass) THEN
            IF ClassDescendsFrom(newClass, oldClass) THEN
                Recreate(SELF, SizeOfCp(TPSliceTable(oldClass)),
                               SizeOfCP(TPSliceTable(newClass)), TPSliceTable(newClass)) (*^*)
            ELSE
                {$IFC fDbgObject}
                ABCBreak('An Object cannot move to an unrelated class', ORD(newClass))
                {$ENDC};
        JoinClass := SELF;
        {$IFC fTrace}EP;{$ENDC}
    END;
    {$S SgCLAres}


{$S sInit1}
BEGIN {Class Initialization}

    InitClascal(ClascalError);	 {Provide an error routine in case of errors in Clascal run-time support}
    InitObject;			 {Do remaining initialization}

    UnitAuthor('Apple');

    cObject := THISCLASS;

END;




